# This file is part of the Net::Tube module.
#
# Net::Tube is Free Software; you can use it, redistribute it and/or
# modify it under the terms of either:
#
# a) the GNU General Public License as published by the Free Software
#    Foundation, either version 2, or (at your opinion) any later
#    version, or
#
# b) the "Artistic License" which comes with Perl.
#

package Net::Tube;

use 5.008008;
use strict;
use warnings;

our @ISA = qw();

our $VERSION = '0.01';


# Preloaded methods go here.

1;

package Net::Tube::Machine;

# The idea of Net::Tube::Machine is to provide a Application pipeline

use Cache::FileCache;

sub new {
    my $class = shift;
    my $self = bless {}, $class;
    return $self;
}

sub keep_bucket {
    my $self = shift;
    if ( scalar @_ ){
        $self->{_KEEP_BUCKET} = shift;
    }
    return $self->{_KEEP_BUCKET};
}

sub cache_defaults {
    my $self = shift;
    my $cfg  = {
        default_expires_in => '5 min',
        auto_purge_on_set  => 1,
        auto_purge_on_get  => 1,
    };
    if (@_) {
        my $c = shift;
        if ( defined $c && ref $c ) {
            if ( exists $c->{'cache_root'} && defined $c->{'cache_root'} ) {
                $cfg->{'cache_root'} = $c->{'cache_root'};
            }
            if ( exists $c->{'cache_depth'} && defined $c->{'cache_depth'} ) {
                $cfg->{'cache_depth'} = $c->{'cache_depth'};
            }
            if ( exists $c->{'directory_umask'}
                && defined $c->{'directory_umask'} )
            {
                $cfg->{'directory_umask'} = $c->{'directory_umask'};
            }
            if ( exists $c->{'default_expires_in'}
                && defined $c->{'default_expires_in'} )
            {
                $cfg->{'default_expires_in'} = $c->{'default_expires_in'};
            }
        }
        $self->{CACHE_DEFAULTS} = $cfg;
    }
    unless ( defined $self->{CACHE_DEFAULTS} ) {
        $self->{CACHE_DEFAULTS} = $cfg;
    }
    return $self->{CACHE_DEFAULTS};
}

sub cache {
    my $self = shift;

    unless ( defined $self->{_CACHEOBJECT} ) {
        my $config = $self->cache_defaults;

        if (   exists $config->{'cache_root'}
            && defined $config->{'cache_root'}
            && length $config->{'cache_root'}
            && -d $config->{'cache_root'} )
        {
            $self->{_CACHEOBJECT} = Cache::FileCache->new($config);
        }    
    }
    return $self->{_CACHEOBJECT};
}

sub create_bucket {
    my $self = shift;
    my $bucket;
    if ( scalar @_ ) {
        my $obj = shift;
        my $cls = ref($obj) ? ref($obj) : $obj;
        $bucket = $cls->new();
    }
    else {
        $bucket = Net::Tube::Bucket->new();
    }

    return $bucket;
}

sub set_pipeline {
    my $self = shift;
    if ( scalar @_ ) {
        $self->{_PIPELINE} = [@_];
    }
}

sub add_filter {
    my $self = shift;
    if ( scalar @_ ) {
        unless ( exists $self->{_PIPELINE} 
	      && ref $self->{_PIPELINE} 
	      && scalar @{ $self->{_PIPELINE} } ) {
            $self->{_PIPELINE} = [];
        }
        push @{ $self->{_PIPELINE} }, @_;
    }
}

sub execute {

# execute takes a pipeline definition
# devirated classes my load the pipeline definition from an XML file or a database.

    my $self = shift;

    $self->{_ERROR} = undef;

    my $tube = $self->{_PIPELINE};
    if ( scalar @_ > 0 ) {
        $tube = shift;
    }

    if ( defined $tube && ref $tube ) {
        my $bucket = $self->create_bucket;
        foreach my $filter (@$tube) {
            # warn "run filter \n";
            if ( defined $filter ) {
                my $rf;
                eval {
                    if ( ref $filter )
                    {
                        $rf = $filter;
                    }
                    else {
                        $rf = $filter->new();
                    }
                    $rf->parent_tube($self);

                    $bucket = $rf->process($bucket);
                };
                if ($@) {
                    $self->{_ERROR} = $@;
                    if ( $filter->stop_on_error ) {
                        last;
                    }
                }
            }
        }
        if ( defined $bucket ) {
            # warn "return bucket\n";
            if( $self->keep_bucket() ){
                # warn "return raw bucket\n";
                return $bucket;
            }        
            # warn "return bucket data\n";
            return $bucket->dump();
        }
    }

    return undef;
}

sub error {
    my $self = shift;
    return $self->{_ERROR};
}

1;

package Net::Tube::Bucket;

use XML::LibXML;
use XML::LibXML::XPathContext;

# this is the context information of a bucket. A bucket is passed from one tube filter to another one.

sub new {
    my $class = shift;
    my $self = bless {
        '_DOMDOC' => [],
        '_FORMAT' => 0
    }, $class;
    return $self;
}

sub format_output {
    my $self = shift;
    if ( scalar @_ ) {
        my $f = shift;
        if ($f) {
            $self->{_FORMAT} = 1;
        }
        else {
            $self->{_FORMAT} = 0;
        }
    }
    return $self->{_FORMAT};
}

sub add_node {
    my $self = shift;
    my $n    = shift;
    if ( defined $n && ref $n ) {
        push @{ $self->{_DOMDOC} }, $n;
    }
}

sub count {
    my $self = shift;
    return scalar @{ $self->{_DOMDOC} };
}

sub get_node {
    my $self = shift;
    if ( scalar @_ ) {
        my $i = shift;
        if ( defined $i && $i >= 0 && $i < scalar @{ $self->{_DOMDOC} } ) {
            return $self->{_DOMDOC}[$i];
        }
    }
    return undef;
}

##
# returns a XML::LibXML::NodeList of the DOM nodes stored within the bucket
sub node_list {
    my $self = shift;
    require XML::LibXML::NodeList;
    my $retval = XML::LibXML::NodeList->new();
    $retval->push( @{ $self->{_DOMDOC} } );
    return $retval;
}

sub add_xml {
    my $self = shift;
    my $xml  = shift;
    my $url  = shift;

    # parse the XML
    my $p   = XML::LibXML->new;
    my $dom = $p->parse_string($xml);

    # add the DOM
    if ($dom) {
	if ( defined $url && length $url ) {
	    $dom->setBaseURI($url);
	}
        $self->add_node($dom);
    }
}

sub add_json {
    my $self = shift;
    my $json = shift;
    my $url  = shift;

    if ( defined $json && length $json ) {

        # load the JSON and DOM building modules

        require JSON;
        require XML::LibXML::SAX::Builder;
        require XML::Generator::PerlData;

        # parse the JSON document
        my $o = JSON::jsonToObj($json);
        if ($o) {
            my $b = XML::LibXML::SAX::Builder->new();
            my $p = XML::Generator::PerlData->new(
                Handler  => $b,
                rootname => 'data'
            );

            # transform the JSON into a DOM
            $p->parse($o);

            my $dom = $b->result();

	    if ( defined $url && length $url ) {
		$dom->setBaseURI($url);
	    }

            # add the DOM
            $self->add_node($dom) if defined $dom;
        }
    }
}

sub add_object {
    my $self = shift;
    my $obj  = shift;

    if ( defined $obj && ref $obj eq "HASH" ) {

        # load the DOM building modules
        require XML::LibXML::SAX::Builder;
        require XML::Generator::PerlData;

        my $b = XML::LibXML::SAX::Builder->new();
        my $p = XML::Generator::PerlData->new(
            Handler  => $b,
            rootname => 'data'
        );

        # transform the JSON into a DOM
        $p->parse($obj);

        my $dom = $b->result();

        # add the DOM
        $self->add_node($dom) if defined $dom;
    }
}

sub find_nodes {
    my $self  = shift;
    my $xpath = shift;
    my $retval;
    if ( defined $xpath && length $xpath ) {
        $retval = [];
        my $xc = XML::LibXML::XPathContext->new;

        # no name space support so far
        foreach my $node ( @{ $self->{_DOMDOC} } ) {
            my @n = $xc->findnodes( $xpath, $node );
            if ( scalar @n ) {
                push @$retval, @n;
            }
        }
    }
    return $retval;
}

sub find_values {
    my $self  = shift;
    my $xpath = shift;
    my $retval;
    my $nodes = $self->find_nodes($xpath);
    if ( defined $nodes ) {
        $retval = [ map { $_->textContent(); } @$nodes ];
    }
    return $retval;
}

sub dump {
    my $self = shift;
    my $data = '';      # create the output information
    foreach my $dom ( @{ $self->{_DOMDOC} } ) {
        $data .= $dom->toString( $self->format_output );
    }
    return $data;
}

1;

package Net::Tube::Filter;

# core functions of a tube filter
sub new {
    my $class = shift;

    my $self = bless { '_FATAL_ERROR' => 1 }, $class;
    if ( scalar @_ ) {
        my $cfg = shift;
        if ( defined $cfg && ref $cfg ) {
            foreach my $k ( keys %$cfg ) {
                if ( ref( $cfg->{$k} ) eq "ARRAY" ) {
                    $self->set_config_entry( $k, @{ $cfg->{$k} } );
                }
                else {
                    $self->set_config_entry( $k, $cfg->{$k} );
                }
            }
        }
    }
    return $self;
}

sub set_config {
    my $self = shift;
    my $cfg  = shift;
    $self->{config} = $cfg;
}

sub set_config_entry {
    my $self = shift;
    my $name = shift;

    if ( defined $name && length $name ) {
        unless ( defined $self->{config} && ref $self->{config} ) {
            $self->{config} = {};
        }
        $self->{config}->{$name} = [@_];
    }
}

sub add_config_entry {
    my $self   = shift;
    my $name   = shift;
    my @values = @_;

    if ( defined $name && length $name ) {
        unless ( defined $self->{config}->{$name}
            && ref( $self->{config}->{$name} ) )
        {
            $self->{config}->{$name} = [];
        }
        if ( scalar @values ) {
            push @{ $self->{config}->{$name} }, @values;
        }
    }
}

sub get_config_entry {
    my $self = shift;
    my $name = shift;
    unless ( defined $self->{config} && ref $self->{config} ) {
        return wantarray ? () : undef;
    }
    unless ( defined $self->{config}->{$name}
        && ref( $self->{config}->{$name} ) )
    {
        return wantarray ? () : undef;
    }
    return wantarray ? @{ $self->{config}->{$name} } : $self->{config}->{$name};
}

sub parent_tube {
    my $self = shift;
    if ( scalar @_ ) {
        $self->{_PARENT_TUBE} = shift;
    }
    return $self->{_PARENT_TUBE};
}

sub cache_object {
    my $self = shift;
    my $p    = $self->parent_tube;
    if ( defined $p ) {
        return $p->cache;
    }
    return undef;
}

sub stop_on_error {
    my $self = shift;
    if ( scalar @_ ) {
        $self->{_FATAL_ERROR} = shift;
    }
    return $self->{_FATAL_ERROR};
}

sub create_bucket {
    my $self = shift;
    if ( $self->parent_tube() ) {

        # this is more powerfull
        return $self->parent_tube()->create_bucket(@_);
    }
    else {
        return Net::Tube::Bucket->new();
    }
}

sub process {
    my $self   = shift;
    my $bucket = shift;
    unless ( defined $bucket ) {
        $bucket = $self->create_bucket();
    }
    return $bucket;
}

1;

__END__
# Below is stub documentation for your module. You'd better edit it!

=head1 NAME

Net::Tube - Perl extension for blah blah blah

=head1 SYNOPSIS

  use Net::Tube;
  blah blah blah

=head1 DESCRIPTION

Stub documentation for Net::Tube, created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.


=head1 SEE ALSO

Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.

If you have a mailing list set up for your module, mention it here.

If you have a web site set up for your module, mention it here.

=head1 AUTHOR

Christian Glahn, E<lt>phish@E<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2007 by Christian Glahn

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
at your option, any later version of Perl 5 you may have available.


=cut
